home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1996 #15
/
Monster Media Number 15 (Monster Media)(July 1996).ISO
/
netmail
/
rnr214.zip
/
GENERICF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1996-02-28
|
44KB
|
2,200 lines
unit genericf; {generic functions unit - not rnr-specific at all}
{
Russell_Schulz@locutus.ofB.ORG (960115)
Copyright 1996 Russell Schulz
this code is not in the Public Domain
permission is granted to use these routines in any application regardless
of commercial status as long as the author of these routines assumes no
liability for any damages whatsoever for any reason. have fun.
}
{
version of this unit: 1ish
}
{$define floatingpoint}
{$undef floatingpoint}
interface
uses dos;
const
tab=#9;
esc=#27;
cr=#13;
lf=#10;
space=' ';
comma=',';
alwayslegalchars: set of char=
[
{uppercase letters}
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y','Z',
{lowercase letters}
'a','b','c','d','e','f','g','h','i','j','k','l','m',
'n','o','p','q','r','s','t','u','v','w','x','y','z',
{digits}
'0','1','2','3','4','5','6','7','8','9',
{some punctuation}
'!','#','$','%','&','(',')','-','@','^','_','`','{','}','~',
{and finally, the quote}
''''
];
sometimeslegalchars: set of char=
[
{must be careful with these}
':','.','\'
];
function max(a,b: integer): integer;
function min(a,b: integer): integer;
function lmax(a,b: longint): longint;
function lmin(a,b: longint): longint;
function iifs(abool: boolean; truestring, falsestring: string): string;
function leftjustify(s: string; width: integer; c: char): string;
function rightjustify(s: string; width: integer; c: char): string;
function wordtozstring(w: word; width: integer): string;
function integertozstring(i: integer; width: integer): string;
function longtozstring(l: longint; width: integer): string;
function currenttimestring: string;
function currenttimedigits: string;
function dow: integer;
function extcdow(thedow: word): string;
function cdow: string;
function dayofmonth: integer;
function month: integer;
function extmonthname(themonth: integer): string;
function monthname: string;
function year: integer;
function dayofweek(y,m,d: word): word;
function ymdtostring(year, month, day: word): string;
function dateformatted(y,m,d: word; dateformat: string): string;
function timetostring(atime: longint): string;
function currentdatestring: string;
function getenv(s: string): string;
function numoccur(c: char; s: string): integer;
function hasany(c: char; s: string): boolean;
function hasno(c: char; s: string): boolean;
function unquote(s: string): string;
function crepl(s: string; cold, cnew: char): string;
function unslash(s: string): string;
function unbackslash(s: string): string;
function ununderscore(s: string): string;
function uncomma(s: string): string;
function srepl(s: string; sold, snew: string): string;
function srepli(s: string; sold, snew: string): string;
function sreplmulti(s: string; sold, snew: string): string;
function unspace(s: string): string;
function atow(s: string): word;
function atoi(s: string): integer;
function atol(s: string): longint;
function wtoa(w: word): string;
function itoa(i: integer): string;
function ltoa(l: longint): string;
function lowcase(c: char): char;
function upper(s: string): string;
function lower(s: string): string;
function proper(s: string): string;
function ltrim(s: string): string;
function trim(s: string): string;
function right(s: string; i: integer): string;
function getfirstw(s: string): string;
function chopfirstw(var s: string): string;
function getquoted(s: string): string;
function randomletter: char;
function randomdigit: char;
function getfromaddr(from: string): string;
function getfromname(from: string): string;
function lchop(s: string; i: integer): string;
function nore(s: string): string;
function monthstringtointeger(monthstr: string): integer;
function isalpha(c: char): boolean;
function isdigit(c: char): boolean;
function isalnum(c: char): boolean;
function isidentchar(c: char): boolean;
function islower(c: char): boolean;
function isspace(c: char): boolean;
function snatchint(var s: string): integer;
function isdev(s: string): boolean;
function illegalfn(fn: string): boolean;
function suspiciousfn(fn: string): boolean;
function highestartin(groupdir: string): longint; {used to be word}
function getuniqfile(groupdir: string): string;
function getuniqfext(basename: string): string;
function expand(str: string): string;
function rot13(s: string): string;
function indir(filespec,dir: string): boolean;
function default(defaultstr,possiblyemptystr: string): string;
function rpos(sub: string; whole: string): integer;
function rposc(s: string; c: char): integer;
function fexists(fn: string): boolean;
function dexists(dn: string): boolean;
function getfntime(fn: string): longint;
function getfnsize(fn: string): longint;
function withbackslash(s: string): string;
function nobeep(s: string): string;
function nonastychar(s: string): string;
function gettag(tag: string; s: string): string;
function hexchar(i: integer): char;
function partialmatch(cmd, template, minimum: string): boolean;
function doserrorno: byte;
function wordwith(c:char; s: string): string;
function isasciifile(fn: string): boolean;
function nthfield(astring: string; delim: char; n: integer): string;
function isinlist(astring, alist, delim: string): boolean;
function sornos(n: integer): string;
function regexintext(aregex: string; awholetext: string): boolean;
function enclosedin(astring: string; lchar,rchar: char): boolean;
function isaleapyear(ayear: integer): boolean;
function daysinyear(ayear: integer): integer;
function daysinyearmonth(ayear: integer; amonth: integer): integer;
function dayspast1970(y,m,d: word): longint;
{$ifdef VER40}
function dosversion: word;
{$endif}
{$ifdef floatingpoint}
function ator(s: string): real;
function rtoa(r: real): string;
function rwptoa(r: real; width: integer; precision: integer): string;
function rtonicea(r: real): string;
{$endif}
implementation
function max;
begin
if a>b then max := a else max := b;
end;
function min;
begin
min := -max(-a,-b);
end;
function lmax;
begin
if a>b then lmax := a else lmax := b;
end;
function lmin;
begin
lmin := -lmax(-a,-b);
end;
function iifs;
begin
if abool then
iifs := truestring
else
iifs := falsestring;
end;
function leftjustify;
var
result: string;
begin
result := s;
while length(result)<width do
result := result+c;
leftjustify := result;
end;
function rightjustify;
var
result: string;
begin
result := s;
while length(result)<width do
result := c+result;
rightjustify := result;
end;
function wordtozstring;
var
result: string;
begin
str(w,result);
wordtozstring := rightjustify(result,width,'0');
end;
function integertozstring;
var
result: string;
begin
str(i,result);
integertozstring := rightjustify(result,width,'0');
end;
function longtozstring;
var
result: string;
begin
str(l,result);
longtozstring := rightjustify(result,width,'0');
end;
function currenttimestring;
var
h,m,s,s00: word;
begin
gettime(h,m,s,s00);
currenttimestring :=
integertozstring(h,2)+':'+integertozstring(m,2)+':'+integertozstring(s,2);
end;
function currenttimedigits;
var
h,m,s,s00: word;
begin
gettime(h,m,s,s00);
currenttimedigits :=
integertozstring(h,2)+integertozstring(m,2)+integertozstring(s,2);
end;
function dow;
var
y,m,d,realdow: word;
begin
getdate(y,m,d,realdow);
dow := realdow;
end;
function extcdow;
var
result: string;
begin
result := 'Sunday';
if thedow=1 then result := 'Monday';
if thedow=2 then result := 'Tuesday';
if thedow=3 then result := 'Wednesday';
if thedow=4 then result := 'Thursday';
if thedow=5 then result := 'Friday';
if thedow=6 then result := 'Saturday';
extcdow := result;
end;
function cdow;
begin
cdow := extcdow(dow);
end;
function dayofmonth;
var
y,m,d,dow: word;
begin
getdate(y,m,d,dow);
dayofmonth := d;
end;
function month;
var
y,m,d,dow: word;
begin
getdate(y,m,d,dow);
month := m;
end;
function extmonthname;
var
result: string;
begin
result := 'January';
if themonth=2 then result := 'February';
if themonth=3 then result := 'March';
if themonth=4 then result := 'April';
if themonth=5 then result := 'May';
if themonth=6 then result := 'June';
if themonth=7 then result := 'July';
if themonth=8 then result := 'August';
if themonth=9 then result := 'September';
if themonth=10 then result := 'October';
if themonth=11 then result := 'November';
if themonth=12 then result := 'December';
extmonthname := result;
end;
function monthname;
begin
monthname := extmonthname(month);
end;
function year;
var
y,m,d,dow: word;
begin
getdate(y,m,d,dow);
year := y;
end;
function dayofweek;
var
result: word;
century: word;
year: word;
month: word;
begin
{
from an old sci.math FAQ
15Q: Is there a formula to determine the day of the week, given
the month, day and year?
A: Here is the standard method.
[...]
Another formula is:
W == k + [2.6m - 0.2] - 2C + Y + [Y/4] + [C/4] mod 7
where [] denotes the integer floor function (round down),
k is day (1 to 31)
m is month (1 = March, ..., 10 = December, 11 = Jan, 12 = Feb)
Treat Jan & Feb as months of the preceding year
C is century ( 1987 has C = 19)
Y is year ( 1987 has Y = 87 except Y = 86 for jan & feb)
W is week day (0 = Sunday, ..., 6 = Saturday)
This formula is good for the Gregorian calendar
(introduced 1582 in parts of Europe, adopted in 1752 in Great Britain
and its colonies, and on various dates in other countries).
It handles century & 400 year corrections, but there is still a
3 day / 10,000 year error which the Gregorian calendar does not take.
into account. At some time such a correction will have to be
done but your software will probably not last that long :-) !
References:
Winning Ways by Conway, Guy, Berlekamp is supposed to have it.
Martin Gardner in "Mathematical Carnival".
Michael Keith and Tom Craver, "The Ultimate Perpetual Calendar?",
Journal of Recreational Mathematics, 22:4, pp. 280-282, 1990.
K. Rosen, "Elementary Number Theory", p. 156.
}
year := y;
month := m;
if month<3 then
begin
inc(month,12);
dec(year);
end;
dec(month,2);
century := (year div 100);
year := year mod 100;
result := d+trunc(2.6*month-0.2)-2*century+year+year div 4+century div 4;
{handle negative mods}
result := result mod 7;
if result<0 then
result := 7+result;
dayofweek := result;
end;
function ymdtostring;
begin
ymdtostring := wordtozstring(year,2)+'-'+
wordtozstring(month,2)+'-'+wordtozstring(day,2);
end;
function timetostring;
var
result: string;
dt: datetime;
begin
unpacktime(atime,dt);
result :=
wordtozstring(dt.year,4)+
'/'+wordtozstring(dt.month,2)+
'/'+wordtozstring(dt.day,2)+
'_'+wordtozstring(dt.hour,2)+
':'+wordtozstring(dt.min,2)+
':'+wordtozstring(dt.sec,2);
timetostring := result;
end;
function dateformatted;
const
wstrings='SMTWRFA';
var
result: string;
tempformat: string;
formatchars: integer;
dow: integer;
begin
result := '';
dow := -1; {unknown}
if (dateformat<>'') and (dateformat<>'-') then
begin
tempformat := dateformat;
while tempformat<>'' do
begin
if copy(tempformat,1,1)='s' then
begin
result := result+' ';
formatchars := 1;
end
else if copy(tempformat,1,3)='www' then
begin
if dow<0 then
dow := dayofweek(y,m,d);
result := result+copy(extcdow(dow),1,3);
formatchars := 3;
end
else if copy(tempformat,1,2)='ww' then
begin
if dow<0 then
dow := dayofweek(y,m,d);
result := result+copy(extcdow(dow),1,2);
formatchars := 2;
end
else if copy(tempformat,1,1)='w' then
begin
if dow<0 then
dow := dayofweek(y,m,d);
result := result+copy(wstrings,1+dow,1);
formatchars := 1;
end
else if copy(tempformat,1,4)='yyyy' then
begin
result := result+wordtozstring(y,4);
formatchars := 4;
end
else if copy(tempformat,1,2)='yy' then
begin
result := result+wordtozstring(y mod 100,2);
formatchars := 2;
end
else if copy(tempformat,1,3)='mmm' then
begin
result := result+copy(extmonthname(m),1,3);
formatchars := 3;
end
else if copy(tempformat,1,2)='mm' then
begin
result := result+wordtozstring(m,2);
formatchars := 2;
end
else if copy(tempformat,1,2)='dd' then
begin
result := result+wordtozstring(d,2);
formatchars := 2;
end
else
begin
result := result+copy(tempformat,1,1);
formatchars := 1;
end;
tempformat := lchop(tempformat,formatchars);
end;
end;
dateformatted := result;
end;
function currentdatestring;
var
year, month, day, dayofweek: word;
begin
getdate(year,month,day,dayofweek);
currentdatestring := ymdtostring(year,month,day);
end;
function getenv;
var
result: string;
i: integer;
envseg: word;
envread: integer;
firstb: byte;
thisb: byte;
varname: string;
vardata: string;
done: boolean;
begin
result := '';
envseg := memw[prefixseg:$2c];
envread := 0;
repeat
firstb := mem[envseg:envread];
if firstb>0 then
begin
varname := '';
repeat
thisb := mem[envseg:envread];
inc(envread);
if thisb<>ord('=') then
varname := varname+chr(thisb);
until thisb=ord('=');
vardata := '';
repeat
thisb := mem[envseg:envread];
inc(envread);
if thisb>0 then
vardata := vardata+chr(thisb);
until thisb=0;
done := (varname=s);
if done then
result := vardata;
end;
until (firstb=0) or done;
getenv := result;
end;
function numoccur;
var
result: integer;
i: integer;
begin
result := 0;
for i := 1 to length(s) do
if s[i]=c then
inc(result);
numoccur := result;
end;
function hasany;
begin
hasany := (numoccur(c,s)<>0);
end;
function hasno;
begin
hasno := not hasany(c,s);
end;
function unquote;
begin
if (s[1]='"') and (s[length(s)]='"') then
unquote := copy(s,2,length(s)-2)
else
unquote := s;
end;
function crepl;
var
result: string;
i: integer;
begin
result := s;
for i := 1 to length(result) do
if result[i]=cold then
result[i] := cnew;
crepl := result;
end;
function unslash;
begin
unslash := crepl(s,'/','\');
end;
function unbackslash;
begin
if s='' then
unbackslash := s
else if copy(s,length(s),1)='\' then
unbackslash := copy(s,1,length(s)-1)
else
unbackslash := s;
end;
function ununderscore;
begin
ununderscore := crepl(s,'_',space);
end;
function uncomma;
begin
uncomma := crepl(s,comma,space);
end;
{}{}{}{} { srepl('aa','a','') doesn't work :-( }
function srepl;
var
result: string;
at: integer;
begin
result := s;
if (sold<>'') and (sold<>snew) then
begin
at := 0;
while at<=length(result)-length(sold) do
begin
inc(at);
if result[at]=sold[1] then
if copy(result,at,length(sold))=sold then
begin
if sold=result then
result := snew
else if at=1 then
result := snew+copy(result,length(sold)+1,255)
else if at=length(result)-length(sold)+1 then
result := copy(result,1,at-1)+snew
else
result :=
copy(result,1,at-1)+snew+copy(result,at+length(sold),255);
end;
end;
end;
srepl := result;
end;
function srepli; {case-insensitive}
var
result: string;
at: integer;
uppersold: string;
begin
result := s;
uppersold := upper(sold);
if (sold<>'') and (uppersold<>upper(snew)) then
begin
at := 0;
while at<=length(result)-length(sold) do
begin
inc(at);
if upcase(result[at])=uppersold[1] then
if upper(copy(result,at,length(sold)))=uppersold then
begin
if uppersold=upper(result) then
result := snew
else if at=1 then
result := snew+copy(result,length(sold)+1,255)
else if at=length(result)-length(sold)+1 then
result := copy(result,1,at-1)+snew
else
result :=
copy(result,1,at-1)+snew+copy(result,at+length(sold),255);
end;
end;
end;
srepli := result;
end;
function sreplmulti;
var
result: string;
firstpass: string;
begin
firstpass := srepl(s,sold,snew);
result := firstpass;
if firstpass<>s then
result := srepl(firstpass,sold,snew);
if result<>firstpass then
result := srepl(result,sold,snew);
sreplmulti := result;
end;
function unspace;
var
result: string;
i: integer;
begin
if (numoccur(' ',s)=0) and (numoccur(tab,s)=0) then
result := s
else
begin
result := '';
for i := 1 to length(s) do
if (s[i]<>' ') and (s[i]<>tab) then
result := result+s[i];
end;
unspace := result;
end;
function atow;
var
result: word;
code: word;
begin
val(s,result,code);
atow := result;
end;
function atoi;
var
result: integer;
code: word;
begin
val(s,result,code);
atoi := result;
end;
function atol;
var
result: longint;
code: word;
begin
val(s,result,code);
atol := result;
end;
function wtoa;
begin
wtoa := wordtozstring(w,0);
end;
function itoa;
begin
itoa := integertozstring(i,0);
end;
function ltoa;
begin
ltoa := longtozstring(l,0);
end;
function lowcase; {similar to the supplied upcase}
begin
if (c>='A') and (c<='Z') then
lowcase := chr(ord(c)-ord('A')+ord('a'))
else
lowcase := c;
end;
function upper;
var
result: string;
i: integer;
begin
result := s;
for i := 1 to length(s) do
result[i] := upcase(result[i]);
upper := result;
end;
function lower;
var
result: string;
i: integer;
begin
result := s;
for i := 1 to length(s) do
result[i] := lowcase(result[i]);
lower := result;
end;
function proper;
var
result: string;
i: integer;
shouldup: boolean;
begin
result := s;
shouldup := true;
for i := 1 to length(s) do
begin
if shouldup then
result[i] := upcase(result[i])
else
result[i] := lowcase(result[i]);
shouldup := not isalpha(result[i]);
end;
proper := result;
end;
function ltrim;
var
result: string;
begin
result := s;
while ((result[1]=' ') or (result[1]=tab)) and (length(result)>0) do
result := copy(result,2,255);
ltrim := result;
end;
function trim;
var
result: string;
begin
result := s;
while ((result[length(result)]=' ') or (result[length(result)]=tab)) and
(length(result)>0) do
result := copy(result,1,length(result)-1);
trim := result;
end;
function right;
begin
right := copy(s,max(1,length(s)-i+1),i);
end;
function getfirstw;
var
result: string;
spaceat: integer;
tabat: integer;
begin
result := trim(ltrim(s));
spaceat := pos(' ',result);
tabat := pos(tab,result);
if tabat>0 then
if (spaceat>0) and (tabat>spaceat) then
result := copy(result,1,spaceat-1)
else
result := copy(result,1,tabat-1)
else
if spaceat>0 then
result := copy(result,1,spaceat-1);
getfirstw := result;
end;
function chopfirstw;
var
result: string;
begin
s := trim(ltrim(s));
result := getfirstw(s);
s := ltrim(copy(s,length(result)+1,255));
chopfirstw := result;
end;
function getquoted;
var
result: string;
begin
result := '';
if copy(s,1,1)='"' then
begin
result := copy(s,2,255);
if pos('"',result)=0 then
result := getfirstw(result)
else
result := copy(result,1,pos('"',result)-1);
end
else
result := getfirstw(s);
getquoted := result;
end;
function randomletter;
begin
if random(2)=0 then
randomletter := chr(ord('a')+random(26))
else
randomletter := chr(ord('A')+random(26));
end;
function randomdigit;
begin
randomdigit := chr(ord('0')+random(10));
end;
function getfromaddr;
var
result: string;
at: integer;
begin
at := rpos('<',from); {used to be pos, but that didn't work on illegals}
if at>0 then {Full Name <address>}
result := copy(from,at+1,length(from)-at-1)
else
begin
at := pos(' ',from);
if at>0 then {address (Full Name)}
result := copy(from,1,at-1)
else {address}
result := from;
end;
getfromaddr := result;
end;
{be careful with address like
"Some (Happy) User" <some@happy.com>
- need to grab the right parts right}
function getfromname;
var
result: string;
at: integer;
begin
result := '';
if copy(from,length(from),1)='>' then
begin
at := rpos('<',from); {not pos to avoid breaking illegal headers}
if at>1 then
result := copy(from,1,at-2);
end;
if result='' then
begin
at := pos('(',from);
if at>0 then
result := copy(from,at+1,length(from)-at-1)
else
begin
at := rpos('<',from);
if at>1 then
result := copy(from,1,at-2);
end;
end;
getfromname := unquote(result);
end;
{changed from `chop' to `lchop' since perl's chop chops from the right}
function lchop;
var
result: string;
begin
lchop := copy(s,i+1,255);
end;
function nore;
begin
{should always be 4 and 'Re: ', but uppercase and ltrim to deal with others}
if upper(copy(s,1,3))='RE:' then
nore := ltrim(lchop(s,3))
else
nore := s;
end;
function monthstringtointeger;
var
result: integer;
lowermonthstr: string;
begin
result := 12;
lowermonthstr := lower(monthstr);
if lowermonthstr='jan' then result := 1
else if lowermonthstr='feb' then result := 2
else if lowermonthstr='mar' then result := 3
else if lowermonthstr='apr' then result := 4
else if lowermonthstr='may' then result := 5
else if lowermonthstr='jun' then result := 6
else if lowermonthstr='jul' then result := 7
else if lowermonthstr='aug' then result := 8
else if lowermonthstr='sep' then result := 9
else if lowermonthstr='oct' then result := 10
else if lowermonthstr='nov' then result := 11;
monthstringtointeger := result;
end;
function isalpha;
begin
isalpha := ( (upcase(c)>='A') and (upcase(c)<='Z') );
end;
function isdigit;
begin
isdigit := (c>='0') and (c<='9');
end;
function isalnum;
begin
isalnum := isalpha(c) or isdigit(c);
end;
function isidentchar;
begin
isidentchar := isalpha(c) or isdigit(c) or (c='_');
end;
function islower;
begin
islower := (c>='a') and (c<='z');
end;
function isspace;
begin
isspace := (c=' ') or (c=tab) or (c=cr) or (c=lf);
end;
function snatchint;
var
intsofar: integer;
begin
intsofar := 0;
while (length(s)>0) and not isdigit(s[1]) do
s := lchop(s,1);
while (length(s)>0) and isdigit(s[1]) do
begin
intsofar := 10*intsofar+ord(s[1])-ord('0');
s := lchop(s,1);
end;
snatchint := intsofar;
end;
function isdev;
{isdev is not perfect -- it always stops on the 128th iteration, just in case}
var
result: boolean;
offs: word;
segm: word;
oldsegm: word;
foundnul: boolean;
basename: string;
i: integer;
iterations: integer;
begin
result := false;
iterations := 0;
segm := 0;
offs := $400;
basename := upper(unslash(s));
{handle LPT1: case}
if copy(basename,length(basename),1)=':' then
basename := copy(basename,1,length(basename)-1);
{strip disk and path designators}
while pos(':',basename)<>0 do
basename := copy(basename,pos(':',basename)+1,255);
while pos('\',basename)<>0 do
basename := copy(basename,pos('\',basename)+1,255);
{strip anything after the first period}
if pos('.',basename)<>0 then
basename := copy(basename,1,pos('.',basename)-1);
{NUL is supposed to be guaranteed the first in the chain}
foundnul := false;
while (not foundnul) and (offs>0) do
begin
{offs is always in range 1..400 here}
if (mem[segm:offs]=ord('N')) and
(mem[segm:offs+1]=ord('U')) and
(mem[segm:offs+2]=ord('L')) and
(mem[segm:offs+3]=ord(' ')) and
(mem[segm:offs+4]=ord(' ')) and
(mem[segm:offs+5]=ord(' ')) and
(mem[segm:offs+6]=ord(' ')) and
(mem[segm:offs+7]=ord(' ')) then
begin
if offs<6 then
begin
writeln('!! error in isdev: offs<6, first loop -- see source');
halt(1);
end;
{$ifdef devverbose}
writeln('found NUL at ',offs);
writeln('attrib=',memw[segm:offs-6]);
{$endif}
if memw[segm:offs-6]=$8004 then
begin
{$ifdef devverbose}
writeln('looks like the real NUL to me!');
{$endif}
foundnul := true;
end;
end;
if not foundnul then
inc(offs);
end;
if foundnul then
begin
while length(basename)<8 do
basename := basename+' ';
if offs<10 then
begin
inc(offs,32);
dec(segm,2);
end;
if offs>65000 then
begin
dec(offs,32);
inc(segm,2);
end;
while not result and
(meml[segm:offs-10]<>$ffffffff) and
(iterations<128) do
begin
inc(iterations);
result := true;
for i := 0 to 7 do
result := result and (chr(mem[segm:offs+i])=basename[1+i]);
{$ifdef devverbose}
writeln('name of device=',
chr(mem[segm:offs]),
chr(mem[segm:offs+1]),
chr(mem[segm:offs+2]),
chr(mem[segm:offs+3]),
chr(mem[segm:offs+4]),
chr(mem[segm:offs+5]),
chr(mem[segm:offs+6]),
chr(mem[segm:offs+7]),
'.');
writeln('new position: ',memw[segm:offs-10],':',memw[segm:offs-8]);
{$endif}
oldsegm := segm;
segm := memw[oldsegm:offs-8];
offs := memw[oldsegm:offs-10];
if offs<10 then
begin
inc(offs,32);
dec(segm,2);
end;
if offs>65000 then
begin
dec(offs,32);
inc(segm,2);
end;
offs := offs+10;
end;
end;
if iterations>=128 then
writeln(
'(don''t worry!) isdev could not check for a device,',
' continuing anyway');
isdev := result;
end;
{$ifdef testfn}
program testfn; {tests what characters are legal in filenames}
var
i: integer;
fn: string;
f: text;
begin
for i := 1 to 255 do
begin
fn := '';
fn := fn+chr(((i ) div 100)+ord('0'));
fn := fn+chr(((i mod 100) div 10)+ord('0'));
fn := fn+chr(((i mod 10) )+ord('0'));
fn := fn+'_';
fn := fn+chr(i);
assign(f,fn);
{$I-}
rewrite(f);
{$I+}
if ioresult=0 then
close(f);
writeln(i);
end;
end.
{$endif}
function illegalfn; {only works on unslash()ed strings}
var
result: boolean;
i: integer;
components: string;
acomponent: string;
begin
{if colon, must be col 2 -- don't use things like lpt1: or com1: }
result := false;
if numoccur(':',fn)>1 then { can't have two colons }
result := true
else if (pos(':',fn)<>0) and (pos(':',fn)<>2) then
result := true;
for i := 1 to length(fn) do
if not result then
if not (fn[i] in alwayslegalchars) then
if not (fn[i] in sometimeslegalchars) then
result := true;
if not result then
begin
components := fn;
if pos(':',components)<>0 then
components := copy(components,pos(':',components)+1,255);
components := trim(ltrim(crepl(components,'\',' ')));
while components<>'' do
begin
acomponent := chopfirstw(components);
for i := 1 to length(acomponent) do
if numoccur('.',acomponent)>1 then
result := true
else if acomponent[1]='.' then
result := true;
end;
end;
illegalfn := result;
end;
function suspiciousfn;
{note that unslash must have already been used!}
var
result: boolean;
upfn: string;
begin
result := false;
upfn := upper(fn);
if illegalfn(upfn) then
result := true
else if numoccur(':',upfn)>0 then
result := true
else if numoccur('\',upfn)>0 then
result := true
else {common devices just in case isdev misses them}
if (upfn='CON') or
(upfn='PRN') or
(upfn='AUX') or
(upfn='NUL') or
(upfn='LPT1') or
(upfn='LPT2') or
(upfn='LPT3') or
(upfn='COM1') or
(upfn='COM2') or
(upfn='COM3') or
(upfn='COM4') or
(upfn='CLOCK$') then
result := true
else {isdev uses icky memory peeking, so don't run it if you can avoid it}
if isdev(upfn) then
result := true;
suspiciousfn := result;
end;
function highestartin;
var
result: longint;
fileinfo: searchrec;
begin
result := 0;
findfirst(withbackslash(groupdir)+'*',archive,fileinfo);
while doserror=0 do
begin
result := lmax(result,atol(fileinfo.name));
findnext(fileinfo);
end;
highestartin := result;
end;
function getuniqfile;
var
result: string;
mangledgroupdir: string;
begin
mangledgroupdir := groupdir;
{}{need to keep each directory under 8 chars}
{avoid problems when keeping outbox copy for mail to foo@prn.com etc.}
if isdev(mangledgroupdir) then
begin
mangledgroupdir := groupdir+'_';
{some device names are 8 chars, and just adding a `_' won't help}
if isdev(mangledgroupdir) then
mangledgroupdir := copy(groupdir,1,length(groupdir)-1)+'_';
end;
getuniqfile := withbackslash(mangledgroupdir)+
ltoa(highestartin(mangledgroupdir)+1);
end;
function getuniqfext;
var
result: word;
fileinfo: searchrec;
filefound: string;
mangledbasename: string;
begin
result := 0;
mangledbasename := basename;
{}{need to keep each directory under 8 chars}
{avoid problems when keeping outbox copy for mail to foo@prn.com etc.}
if isdev(mangledbasename) then
begin
mangledbasename := basename+'_';
{some device names are 8 chars, and just adding a `_' won't help}
if isdev(mangledbasename) then
mangledbasename := copy(basename,1,length(basename)-1)+'_';
end;
findfirst(mangledbasename+'.*',archive,fileinfo);
while doserror=0 do
begin
filefound := fileinfo.name;
while pos('.',filefound)>0 do
filefound := copy(filefound,pos('.',filefound)+1,255);
result := max(result,atoi(filefound));
findnext(fileinfo);
end;
getuniqfext := mangledbasename+'.'+wtoa(result+1);
end;
function expand;
var
work: string;
i,j: integer;
begin
if pos(tab,str)=0 then
expand := str
else
begin
work := '';
for i := 1 to length(str) do
if length(work)<240 then
if str[i]=tab then
for j := 1 to 8-(length(work) and 7) do
work := work+' '
else
work := work+str[i];
expand := work;
end;
end;
function rot13;
var
result: string;
upc: char;
i: integer;
begin
result := s;
for i := 1 to length(result) do
begin
upc := upcase(result[i]);
if (upc>='A') and (upc<='M') then
result[i] := chr(ord(result[i])+13)
else if (upc>='N') and (upc<='Z') then
result[i] := chr(ord(result[i])-13);
end;
rot13 := result;
end;
function indir;
var
fileinfo: searchrec;
begin
findfirst(withbackslash(dir)+filespec,archive,fileinfo);
indir := (doserror=0);
end;
function default;
begin
if possiblyemptystr='' then
default := defaultstr
else
default := possiblyemptystr;
end;
function rpos;
var
result: integer;
i: integer;
begin
result := 0;
for i := 1 to length(whole)-length(sub)+1 do
if copy(whole,i,length(sub))=sub then
result := i;
rpos := result;
end;
function rposc;
var
result: integer;
i: integer;
begin
result := 0;
for i := 1 to length(s) do
if s[i]=c then
result := i;
rposc := result;
end;
function fexists;
var
result: boolean;
f: text;
begin
result := false;
assign(f,fn);
{$I-}
reset(f);
{$I+}
if ioresult=0 then
begin
close(f);
result := true;
end;
fexists := result;
end;
function dexists;
var
result: boolean;
newdn: string;
fileinfo: searchrec;
begin
result := false;
newdn := unslash(dn);
if right(newdn,1)='\' then
newdn := newdn+'.';
if right(newdn,1)=':' then
newdn := newdn+'.';
findfirst(newdn,directory,fileinfo);
if doserror=0 then
if (fileinfo.attr and directory)<>0 then
result := true;
dexists := result;
end;
function getfntime;
var
result: longint;
f: text;
begin
result := 0;
assign(f,fn);
{$I-}
reset(f);
{$I+}
if ioresult=0 then
begin
getftime(f,result);
close(f);
end;
getfntime := result;
end;
{size from a filename, not from a file handle}
function getfnsize;
var
result: longint;
f: file;
begin
result := -1;
assign(f,fn);
{$I-}
reset(f,1);
{$I+}
if ioresult=0 then
begin
result := filesize(f);
close(f);
end;
getfnsize := result;
end;
function withbackslash; {nonempty gets terminated with backslash}
var
result: string;
begin
result := s;
if result<>'' then
if result[length(result)]<>'\' then
result := result+'\';
withbackslash := result;
end;
function nobeep;
var
result: string;
begin
result := crepl(s,chr(7),'^');
nobeep := result;
end;
function nonastychar;
var
result: string;
begin
result := crepl(s,chr(7),'^');
result := crepl(result,chr(27),'^');
nonastychar := result;
end;
function gettag;
var
result: string;
begin
result := '';
if pos(tag,s)<>0 then
begin
result := copy(s,pos(tag,s)+length(tag),255);
result := getquoted(result);
end;
gettag := result;
end;
function hexchar;
begin
if i<10 then
hexchar := chr(ord('0')+i)
else
hexchar := chr(ord('a')+i-10);
end;
function partialmatch;
var
result: boolean;
begin
result := false;
if (length(cmd)<=length(template)) and (length(cmd)>=length(minimum)) then
if copy(template,1,length(cmd))=cmd then
result := true;
partialmatch := result;
end;
function doserrorno; {prevents units having to include dos for 1 call}
begin
doserrorno := doserror;
end;
function wordwith;
var
result: string;
temps: string;
begin
result := '';
temps := s;
while (result='') and (temps<>'') do
begin
result := chopfirstw(temps);
if pos(c,result)=0 then
result := '';
end;
wordwith := result;
end;
function isasciifile;
const
checkedsize=1024;
var
result: boolean;
{$ifdef veryslowisasciifile}
inf: file of byte;
{$endif}
inf: file;
whichbyte: integer;
onebyte: byte;
{$ifdef veryslowisasciifile}
stillsearching: boolean;
{$endif}
buffer: array[1..checkedsize] of byte;
numread: word;
begin
result := true;
{$ifdef veryslowisasciifile}
assign(inf,fn);
{$I-}
reset(inf);
{$I+}
{$endif}
assign(inf,fn);
{$I-}
reset(inf,1);
{$I+}
if ioresult<>0 then
result := false
else
begin
{$ifdef veryslowisasciifile}
stillsearching := true;
for whichbyte := 1 to checkedsize do
if stillsearching then
begin
if eof(inf) then
stillsearching := false
else
begin
read(inf,onebyte);
if not
(
(onebyte=9)
or
(onebyte=10)
or
(onebyte=13)
or
( (onebyte>=32) and (onebyte<=126) )
)
then
begin
result := false;
stillsearching := false;
end;
end;
end;
close(inf);
{$endif}
blockread(inf,buffer,checkedsize,numread);
close(inf);
for whichbyte := 1 to numread do
if result then
begin
onebyte := buffer[whichbyte];
if not
(
(onebyte=9)
or
(onebyte=10)
or
(onebyte=13)
or
( (onebyte>=32) and (onebyte<=126) )
)
then
result := false;
end;
end;
isasciifile := result;
end;
function nthfield;
var
result: string;
chopfieldcount: integer;
delimpos: integer;
tempstring: string;
begin
tempstring := astring;
for chopfieldcount := 1 to n-1 do
tempstring := lchop(tempstring,pos(delim,tempstring));
delimpos := pos(delim,tempstring);
if delimpos=0 then
result := ''
else
result := copy(tempstring,1,delimpos-1);
nthfield := result;
end;
function isinlist;
begin
isinlist := pos(delim+upper(astring)+delim,delim+upper(alist)+delim)<>0;
end;
function sornos;
begin
if n=1 then sornos := '' else sornos := 's';
end;
{}{}{}{} { this is NOT full regex at this time }
function regexintext;
var
result: boolean;
mangledaregex: string;
onesearch: string;
foundend: boolean;
escaped: boolean;
onech: char;
begin
result := false;
if pos('|',aregex)=0 then
result := pos(aregex,awholetext)<>0
else
begin
mangledaregex := aregex;
while (mangledaregex<>'') and not result do
begin
onesearch := '';
escaped := false;
foundend := false;
while not foundend do
begin
if mangledaregex='' then
foundend := true
else
begin
onech := mangledaregex[1];
mangledaregex := lchop(mangledaregex,1);
if escaped then
begin
escaped := false;
onesearch := onesearch+onech;
end
else if onech='\' then
begin
escaped := true;
end
else
begin
escaped := false;
if onech='|' then
foundend := true
else
onesearch := onesearch+onech;
end;
end;
end;
result := pos(onesearch,awholetext)<>0;
end;
end;
regexintext := result;
end;
function enclosedin;
begin
if length(astring)<2 then
enclosedin := false
else
enclosedin := (astring[1]=lchar) and (astring[length(astring)]=rchar);
end;
function isaleapyear;
begin
if (ayear mod 400)=0 then
isaleapyear := true
else if (ayear mod 100)=0 then
isaleapyear := false
else if (ayear mod 4)=0 then
isaleapyear := true
else
isaleapyear := false;
end;
function daysinyear;
begin
if isaleapyear(ayear) then
daysinyear := 366
else
daysinyear := 365;
end;
function daysinyearmonth;
begin
case amonth of
1: daysinyearmonth := 31;
2: if isaleapyear(ayear) then
daysinyearmonth := 29
else
daysinyearmonth := 28;
3: daysinyearmonth := 31;
4: daysinyearmonth := 30;
5: daysinyearmonth := 31;
6: daysinyearmonth := 30;
7: daysinyearmonth := 31;
8: daysinyearmonth := 31;
9: daysinyearmonth := 30;
10: daysinyearmonth := 31;
11: daysinyearmonth := 30;
12: daysinyearmonth := 31;
end;
end;
function dayspast1970;
var
result: longint;
ayear: integer;
amonth: integer;
begin
result := 0;
if y>=1970 then
begin
for ayear := 1970 to y-1 do
inc(result,daysinyear(ayear));
for amonth := 1 to m-1 do
inc(result,daysinyearmonth(ayear,amonth));
inc(result,d-1);
end;
dayspast1970 := result;
end;
{weird code follows}
{$ifdef VER40}
function dosversion;
var
regs: registers;
begin
regs.ah := $30;
msdos(regs);
dosversion := regs.ax;
end;
{$endif}
{$ifdef floatingpoint}
function ator;
var
r: real;
code: word;
begin
val(s,r,code);
ator := r;
end;
function rtoa;
var
a: string;
begin
str(r,a);
rtoa := a;
end;
function rwptoa;
var
a: string;
begin
str(r:width:precision,a);
rwptoa := a;
end;
function rtonicea;
var
a: string;
begin
str(r:0:10,a);
while (length(a)>1) and (right(a,1)='0') do
a := copy(a,1,length(a)-1);
if right(a,1)='.' then
a := copy(a,1,length(a)-1);
rtonicea := a;
end;
{$endif}
end.